define-record in racket macros

define-record.rkt

#lang racket
(require racket/syntax)
(require (for-syntax racket/syntax))
(require macro-debugger/expand)
(require syntax/parse/define)
(require
  racket/stxparam
  (for-syntax syntax/parse))

(define-syntax (define-record stx)
    (syntax-case stx ()
      [(_ id (fields ...))
       (with-syntax ([make-id (format-id #'id "make-~a" #'id)] [pred-id (format-id #'id "~a?" #'id)])
         #`(begin
             ; Define a constructor.
             (define (make-id fields ...)
               (apply vector (cons 'id  (list fields ...))))
             ; Define a predicate.
             (define (pred-id v)
               (and (vector? v)
                    (eq? (vector-ref v 0) 'id)))
             ; Define an accessor for each field.
             #,@(for/list ([x (syntax->list #'(fields ...))]
                           [n (in-naturals 1)])
                  (with-syntax ([acc-id (format-id #'id "~a->~a" #'id x)]
                                [ix n])
                    #`(define (acc-id v)
                        (unless (pred-id v)
                          (error 'acc-id "~a is not a ~a struct" v 'id))
                        (vector-ref v ix))))))]))

(define-syntax variant-case
  (syntax-rules (else)
    [(_ (a . d) clause ...)
     (let ([var (a . d)]) (variant-case var clause ...))]
    [(_ var) (error 'variant-case "no clause matches ~s" var)]
    [(_ var (else exp1 exp2 ...)) (begin exp1 exp2 ...)]
    [(_ var (name (field . fields) exp1 exp2 ...) clause ...)
     (with-syntax ([name? (format-id #'name "~a?" #'name)]
                   [name-field-pairs-list (map
                                     (lambda (fld) (list fld
                                                         (list (format-id #'name "~a->~a" #'name fld) #'var)))
                                     (cons (syntax->datum #'field) (syntax->datum #'fields)))])
       #'(if (name? var)
             (let name-field-pairs-list exp1 exp2 ...)
             (variant-case var clause ...)))]))

expanded.rkt

(define leaf-sum-expanded
  (lambda (tree)
    (if (leaf? tree) (let ((number (leaf->number tree))) number)
         (if (interior? tree)
             (let ((left-tree (interior->left-tree tree)) (right-tree (interior->right-tree tree))) (+ (leaf-sum-expanded left-tree) (leaf-sum-expanded right-tree)))
             (variant-case tree (else (error "leaf-sum: Invalid tree" tree)))))))

usage.scm

(define-record interior (symbol left-tree right-tree))
(define-record leaf (number))

(define leaf-sum
  (lambda (tree)
    (variant-case tree
                  (leaf (number) number)
                  (interior (left-tree right-tree)
                            (+ (leaf-sum left-tree) (leaf-sum right-tree)))
                  (else (error "leaf-sum: Invalid tree" tree)))))
                  
(define tree-1 (make-interior 'foo (make-interior 'bar (make-leaf 1) (make-leaf 2)) (make-leaf 3)))

(leaf-sum tree-1)