--- /dev/null
+(define-syntax define-record
+ (lambda (e)
+ (syntax-case e ()
+ ((_ name field0 field1 ...)
+ (with-syntax ((%fields
+ (map (lambda (f)
+ (syntax-case f ()
+ ((fname) (syntax (field fname #f)))
+ ((fname default) (syntax (field fname default)))
+ (fname (syntax (field fname #f)))))
+ (syntax (field0 field1 ...)))))
+ (syntax
+ (define-record* name
+ %fields)))))))
+
+(define-syntax define-record*
+ (lambda (e)
+ (letrec ((make-name (lambda args
+ (datum->syntax e
+ (string->symbol
+ (apply string-append
+ (map (lambda (a)
+ (if (string? a)
+ a
+ (symbol->string
+ (syntax->datum a))))
+ args)))))))
+ (syntax-case e (field)
+ ((_ name ((field field-name default) ...))
+ #`(begin (define* (#,(make-name "make-" (syntax name))
+ #:optional (field-name default) ...)
+ (vector 'name field-name ...))
+ #,@(let ((idx 0))
+ (map (lambda (fname)
+ (set! idx (1+ idx))
+ #`(begin (define (#,(make-name (syntax name)
+ ":"
+ fname)
+ rec)
+ (vector-ref rec #,idx))
+ (define (#,(make-name "set-"
+ (syntax name)
+ ":"
+ fname)
+ rec val)
+ (vector-set! rec #,idx val))))
+ (syntax (field-name ...))))))))))
+