Below is a syntax-case implementation (MzScheme version) for comment.
Apologies for the long text.

Andre

;===========================================================================================
; Syntax-Case (MzScheme version) Implementation:
;
; Andre van Tonder, 2005.
;
;============================================================================================

(module registry mzscheme

   (provide register
            make-entry
            lookup-entry
            lookup-scheme?
            lookup-getter
            lookup-setter
            lookup-labels
            lookup-supers
            lookup-copier
            lookup-predicate)

   (require (prefix s1: (lib "1.ss" "srfi")))

   (define reg '())

   (define (make-entry name
                       is-scheme?
                       predicate
                       supers
                       labels
                       pos-labels
                       fields
                       copier)
     (vector name
             is-scheme?
             predicate
             supers
             labels
             pos-labels
             fields
             copier))

   (define (entry.name entry)       (vector-ref entry 0))
   (define (entry.is-scheme? entry) (vector-ref entry 1))
   (define (entry.predicate entry)  (vector-ref entry 2))
   (define (entry.supers entry)     (vector-ref entry 3))
   (define (entry.labels entry)     (vector-ref entry 4))
   (define (entry.pos-labels entry) (vector-ref entry 5))
   (define (entry.fields entry)     (vector-ref entry 6))
   (define (entry.copier entry)     (vector-ref entry 7))

   (define (register name entry)
     (cond ((s1:assoc name reg free-identifier=?)
            => (lambda (pair)
                 (set-cdr! pair entry)))
           (else
            (set! reg (cons (cons name entry)
                            reg)))))

   (define (lookup-entry name)
     (s1:assoc name reg free-identifier=?))

   (define (lookup-getter name label)
     (cond ((s1:assoc label
                      (entry.fields (cdr (lookup-entry name)))
                      free-identifier=?)
            => cadr)
           (else #f)))

   (define (lookup-setter name label)
     (cond ((s1:assoc label
                      (entry.fields (cdr (lookup-entry name)))
                      free-identifier=?)
            => caddr)
           (else #f)))

   (define (lookup-scheme? name)   (entry.is-scheme? (cdr (lookup-entry name))))
   (define (lookup-labels name)    (entry.labels     (cdr (lookup-entry name))))
   (define (lookup-supers name)    (entry.supers     (cdr (lookup-entry name))))
   (define (lookup-copier name)    (entry.copier     (cdr (lookup-entry name))))
   (define (lookup-predicate name) (entry.predicate  (cdr (lookup-entry name))))

   ) ; registry

(module records mzscheme

   (provide define-record-type
            define-record-scheme
            record-update
            record-update!
            record-compose
            show)

   (require            (prefix s9: (lib "9.ss" "srfi")))
   (require-for-syntax (prefix s1: (lib "1.ss" "srfi")))

   (require-for-syntax registry)

   (define-syntax define-record-type
     (syntax-rules ()
       ((define-record-type . body)
        (parse-declaration #f . body))))

   (define-syntax define-record-scheme
     (syntax-rules ()
       ((define-record-scheme . body)
        (parse-declaration #t . body))))

   (define-syntax parse-declaration
     (syntax-rules ()
       ((parse-declaration is-scheme? (name super ...) (constructor pos-label ...) predicate field-clause ...)
        (build-record (constructor pos-label ...)  #f (super ...) (field-clause ...) name predicate is-scheme?))
       ((parse-declaration is-scheme? (name super ...) constructor predicate field-clause ...)
        (build-record (constructor)  #t (super ...) (field-clause ...) name predicate is-scheme?))
       ((parse-declaration is-scheme? (name super ...) constructor-clause)
        (parse-declaration is-scheme? (name super ...) constructor-clause #f))
       ((parse-declaration is-scheme? (name super ...))
        (parse-declaration is-scheme? (name super ...) #f #f))
       ((parse-declaration is-scheme? name . rest)
        (parse-declaration is-scheme? (name) . rest))))

   (define-syntax record-update!
     (lambda (stx)
       (syntax-case stx ()
         ((_ record name (label exp) ...)
          (with-syntax (((setter ...)
                         (map (lambda (label)
                                (lookup-setter #`name label))
                              (syntax->list #`(label ...)))))
            #`(let ((r record))
                (setter r exp)
                ...
                r))))))

   (define-syntax record-update
     (lambda (stx)
       (syntax-case stx ()
         ((_ record name (label exp) ...)
          (if (lookup-scheme? #`name)
              (with-syntax ((copier (lookup-copier #`name)))
                #`(let ((new (copier record)))
                    (record-update! new name (label exp) ...)))
              #`(record-compose (name record) (name (label exp) ...)))))))

   (define-syntax record-compose
     (lambda (stx)
       (syntax-case stx ()
         ((record-compose (export-name (label exp) ...))
          #`(export-name (label exp) ...))
         ((record-compose (import-name record) import ... (export-name (label exp) ...))
          (with-syntax
              (((copy-label ...)
                (s1:lset-intersection free-identifier=?
                                      (lookup-labels #`export-name)
                                      (s1:lset-difference free-identifier=?
                                                          (lookup-labels #`import-name)
                                                          (syntax->list #`(label ...))))))
            (with-syntax (((getter ...)
                           (s1:map (lambda (label)
                                     (lookup-getter #`import-name label))
                                   (syntax->list #`(copy-label ...)))))
              #`(let ((r record))
                  (record-compose import ...
                                  (export-name (copy-label (getter r))
                                               ...
                                               (label exp)
                                               ...)))))))))

   (define-syntax build-record
     (let ()

       (define (build-record stx)
         (syntax-case stx ()
           ((build-record (constructor pos-label ...)
                          default-order?
                          (super ...)
                          ((field-label . accessors) ...)
                          name
                          predicate
                          is-scheme?)
            (with-syntax
                (((label ...)
                  (s1:delete-duplicates (s1:fold-right append
                                                       (syntax->list #`(pos-label ... field-label ...))
                                                       (map lookup-labels
                                                            (syntax->list #`(super ...))))
                                        free-identifier=?))
                 ((super ...)
                  (s1:delete-duplicates (s1:fold-right append
                                                       '()
                                                       (map lookup-supers
                                                            (syntax->list #`(super ...))))
                                        free-identifier=?)))
              (with-syntax
                  (((pos-label ...)

                    (if (syntax-e #`default-order?)
                        #`(label ...)
                        #`(pos-label ...)))

                   (((field-label getter setter) ...)

                    (append (map augment-field
                                 (syntax->list #`((field-label . accessors) ...)))
                            (map (lambda (label)
                                   (maybe-generate #`name `(,label getter setter)))
                                 (s1:lset-difference free-identifier=?
                                                     (syntax->list #`(label ...))
                                                     (syntax->list #`(field-label ...)))))))

                (with-syntax ((supers         #`(super ...))
                              ((pos-temp ...) (generate-temporaries #`(pos-label ...)))
                              ((constructor predicate maker copier)
                               (maybe-generate #`name `(,#`constructor ,#`predicate maker copier))))
                  (begin
                    (register #`name (make-entry #`name
                                                 (syntax-e #`is-scheme?)
                                                 #`predicate
                                                 (syntax->list #`(super ... name))
                                                 (syntax->list #`(label ...))
                                                 (syntax->list #`(pos-label ...))
                                                 (map syntax->list
                                                      (syntax->list #`((field-label getter setter) ...)))
                                                 #`copier))

                    (if (syntax-e #`is-scheme?)

                        #`(begin
                            (define-generic (predicate x) (lambda (x) #f))
                            (define-generic (getter x))
                            ...
                            (define-generic (setter x v))
                            ...
                            (define-generic (copier x)))

                        #`(begin
                            (s9:define-record-type internal-name
                                                   (maker field-label ...)
                                                   predicate
                                                   (field-label getter setter) ...)

                            (define constructor
                              (lambda (pos-temp ...)
                                (populate maker (field-label ...) (pos-label pos-temp) ...)))

                            (extend-predicates supers predicate)
                            (extend-accessors supers field-label predicate getter setter)
                            ...

                            (define (copier x)
                              (maker (getter x) ...))
                            (extend-copiers supers copier predicate)

                            (define-method (show (r predicate))
                              (list 'name
                                    (list 'field-label (getter r))
                                    ...))

                            (define-syntax name
                              (syntax-rules ()
                                ((name . bindings) (populate maker (field-label ...) . bindings))))

                            ))))))))) ; build-record

       (define (maybe-generate context maybe-identifiers)
         (map (lambda (elem)
                (if (identifier? elem)
                    elem
                    (datum->syntax-object context (if (symbol? elem)
                                                      (gensym elem)
                                                      (gensym)))))
              maybe-identifiers))

       (define (augment-field clause)
         (syntax-case clause ()
           ((label)               `(,#`label ,@(maybe-generate #`label `(   getter    setter))))
           ((label getter)        `(,#`label ,@(maybe-generate #`label `(,#`getter    setter))))
           ((label getter setter) `(,#`label ,@(maybe-generate #`label `(,#`getter ,#`setter))))))

       build-record))

   (define-syntax extend-predicates
     (lambda (stx)
       (syntax-case stx ()
         ((extend-predicates (super ...) new-type)
          (with-syntax (((predicate ...) (map lookup-predicate
                                              (syntax->list #`(super ...)))))
            #`(begin
                (define-method predicate (new-type) (x) any?)
                ...))))))

   (define-syntax extend-copiers
     (lambda (stx)
       (syntax-case stx ()
         ((extend-copiers (super ...) copy new-type)
          (with-syntax (((copier ...) (map lookup-copier
                                           (syntax->list #`(super ...)))))
            #`(begin
                (define-method copier (new-type) (x)  copy)
                ...))))))

   (define-syntax extend-accessors
     (lambda (stx)
       (syntax-case stx ()
         ((extend-accessors (super ...) label new-type selector modifier)
          (with-syntax (((getter ...) (s1:filter (lambda (id)
                                                   (not (eqv? id #f)))
                                                 (map (lambda (super)
                                                        (lookup-getter super #`label))
                                                      (syntax->list #`(super ...)))))
                        ((setter ...) (s1:filter (lambda (id)
                                                   (not (eqv? id #f)))
                                                 (map (lambda (super)
                                                        (lookup-setter super #`label))
                                                      (syntax->list #`(super ...))))))
            #`(begin
                (define-method getter (new-type) (x) selector)
                ...
                (define-method setter (new-type any?) (x v) modifier)
                ...))))))

   (define-syntax populate
     (lambda (stx)

       (define (order ordering bindings default)
         (if (null? (s1:lset-difference free-identifier=?
                                        (map car bindings)
                                        ordering))
             (map (lambda (label)
                    (cond ((s1:assoc label bindings free-identifier=?) => (lambda (x) x))
                          (else `(,label ,default))))
                  ordering)
             (raise-syntax-error #f "Illegal labels in" stx)))

       (syntax-case stx ()
         ((populate maker labels . bindings)
          (with-syntax ((((label exp) ...) (order (syntax->list #`labels)
                                                  (map syntax->list
                                                       (syntax->list #'bindings))
                                                  #`'<undefined>)))
            #`(maker exp ...))))))

   ; Simple generic functions suitable for our disjoint base record types:

   (define-syntax define-generic
     (syntax-rules ()
       ((define-generic (name arg ...))
        (define-generic (name arg ...)
          (lambda (arg ...) (error "Inapplicable method:" 'name
                                   "Arguments:" (show arg) ... ))))
       ((define-generic (name arg ...) proc)
        (define name (make-generic (arg ...) proc)))))

   (define-syntax define-method
     (syntax-rules ()
       ((define-method (generic (arg pred?) ...) . body)
        (define-method generic (pred? ...) (arg ...) (lambda (arg ...) . body)))
       ((define-method generic (pred? ...) (arg ...) procedure)
        (let ((next ((generic) 'get-proc))
              (proc procedure))
          (((generic) 'set-proc)
           (lambda (arg ...)
             (if (and (pred? arg) ...)
                 (proc arg ...)
                 (next arg ...))))))))

   (define-syntax make-generic
     (syntax-rules ()
       ((make-generic (arg arg+ ...) default-proc)
        (let ((proc default-proc))
          (case-lambda
            ((arg arg+ ...)
             (proc arg arg+ ...))
            (()
             (lambda (msg)
               (case msg
                 ((get-proc) proc)
                 ((set-proc) (lambda (new)
                               (set! proc new)))))))))))

   (define-generic (show x)
     (lambda (x) x))

   (define (any? x) #t)

) ; records

;============================================================================================
; Examples:

(require records)

; A simple record declaration:

(define-record-type point (make-point x y) point?
   (x point.x point.x-set!)
   (y point.y point.y-set!))

(define p (make-point 1 2))

(point? p)             ;==> #t
(point.y p)            ;==> 2
(point.y-set! p 7)
(point.y p)            ;==> 7

; Simple record schemes.
; Record schemes don't have constructors.
; The predicates and accessors are polymorphic.

(define-record-scheme <point #f <point?
   (x <point.x)
   (y <point.y))

(define-record-scheme <color #f <color?
   (hue <color.hue))

; Concrete instances of the above schemes.
; Constructors may be declared.
; Predicates and accessors, when provided, are monomorphic.

(define-record-type (point <point) make-point point?
   (x point.x)
   (y point.y))

(define-record-type (color <color) make-color)

(define-record-type (color-point <color <point) (make-color-point x y hue) color-point?
   (extra color-point.extra))

(define cp (make-color-point 1 2 'blue))

(<point? cp)            ;==> #t
(<color? cp)            ;==> #t
(color-point? cp)       ;==> #t
;(point.x cp)           ;==> error
(<point.y cp)           ;==> 2
(<color.hue cp)         ;==> blue
(color-point.extra cp)  ;==> <undefined>

; Constructing records by field labels:

(define p (point (x 1)
                  (y 2)))
(define cp (color-point (hue 'blue)
                         (x 1)
                         (y 2)))

; Monomorphic functional update:

(show
  (record-update p point (x 7)))     ;==> (point (x 7) (y 2))
(show p)                            ;==> (point (x 1) (y 2))   - original unaffected

; Polymorphic functional update:

(show
  (record-update cp <point (x 7)))   ;==> (color-point (extra <undefined>) (hue blue) (x 7) (y 2))
(show cp)                           ;==> (color-point (extra <undefined>) (hue blue) (x 1) (y 2))

; In-place update:

(show
  (record-update! cp <point (x 7)))  ;==> color-point (extra <undefined>) (hue blue) (x 7) (y 2))
(show cp)                           ;==> color-point (extra <undefined>) (hue blue) (x 7) (y 2))

; Use record-compose for updates polymorphic in argument but monomorphic in result type:

(show
  (record-compose (<point cp) (point (x 8))))  ;==> (point (x 8) (y 2))
(show cp)                                     ;==> (color-point (extra <undefined>) (hue blue) (x 7) (y 2))

; More general record composition example:

(define cp (make-color-point 1 2 'green))
(define c  (make-color 'blue))

(show
  (record-compose (<point cp)                 ; polymorphic import - only fields x and y of cp taken
                  (color c)                   ; monomorphic import
                  (color-point (x 8)          ; override imported field
                               (extra 'hi))))

                                          ;==> (color-point (extra hi) (hue blue) (x 8) (y 2))

; Small module-functor example:

(define-record-type monoid #f #f
   (mult monoid.mult)
   (one  monoid.one))

(define-record-type abelian-group #f #f
   (add  group.add)
   (zero group.zero)
   (sub  group.sub))

(define-record-type ring #f #f
   (mult ring.mult)
   (one  ring.one)
   (add  ring.add)
   (zero ring.zero)
   (sub  ring.sub))

(define integer-monoid (monoid (mult *)
                                (one  1)))

(define integer-group (abelian-group (add  +)
                                      (zero 0)
                                      (sub  -)))

(define (make-ring g m)          ; simple "functor"
   (record-compose (monoid m)
                   (abelian-group g)
                   (ring)))

(define integer-ring (make-ring integer-group
                                 integer-monoid))

((ring.add integer-ring) 1 2)    ;==> 3

; Example of tree data type

(define-record-scheme <tree #f <tree?)

(define-record-type (node <tree) make-node node?
   (lhs node.lhs)
   (rhs node.rhs))

(define-record-type (leaf <tree) make-leaf leaf?
   (val leaf.val))

(define (tree->list t)
   (cond
     ((leaf? t) (leaf.val t))
     ((node? t) (cons (tree->list (node.lhs t))
                      (tree->list (node.rhs t))))))

(define t
   (make-node (make-node (make-leaf 1)
                         (make-leaf 2))
              (make-leaf 3)))

(<tree? t)         ;==> #t
(tree->list t)     ;==> ((1 . 2) . 3)