Racket genericity with match-lambda clauses

my-match-lambda.rkt

#lang racket

(provide my-match-lambda*
         (struct-out my-match-lambda-procedure)
         my-match-lambda-append
         my-match-lambda-add-clause!
         my-match-lambda-add-overriding-clause!
         (struct-out exn:fail:my-match-lambda:no-match)
         (struct-out exn:fail:my-match-lambda:no-match:next-clause)
         raise-my-match-lambda:no-match-error)

(module+ test
  (require rackunit)
  
  (define dup (my-match-lambda*))
  
  (my-match-lambda-add-clause! dup [(list (? string? s)) (string-append s s)])
  (my-match-lambda-add-clause! dup [(list (? integer? n)) (list n n)])
  (my-match-lambda-add-clause! dup [(list (? boolean? n)) (list n n)])
  
  (check-equal? (dup "Hello") "HelloHello")
  (check-equal? (dup 10) '(10 10))
  (check-equal? (dup #t) '(#t #t)))

(define-syntax-rule (my-match-lambda* clause ...)
  (my-match-lambda-procedure
   (list (clause->proc clause) ...)))

(define-syntax-rule (clause->proc clause)
  (match-lambda* clause [args (raise-my-match-lambda:no-match-error args)]))

(struct my-match-lambda-procedure (procs)
  #:transparent #:mutable
  #:property prop:procedure
  (lambda (this . args)
    (let ([procs (my-match-lambda-procedure-procs this)])
      (define proc (apply my-match-lambda-append procs))
      (apply proc args))))

(define within-my-match-lambda-append?
  (make-parameter #f))

(define my-match-lambda-append
  (case-lambda
    [() (case-lambda)]
    [(f1 . f2) (lambda args
               (with-handlers ([exn:fail:my-match-lambda:no-match:next-clause?
                                (λ (e) (apply (apply my-match-lambda-append  f2) args))])
                 (parameterize ([within-my-match-lambda-append? #t])
                   (apply f1 args))))]))

(define-syntax-rule (my-match-lambda-add-clause! proc clause ...)
  (set-my-match-lambda-procedure-procs! proc
                                        (append (my-match-lambda-procedure-procs proc)
                                                (list (clause->proc clause) ...))))

(define-syntax-rule (my-match-lambda-add-overriding-clause! proc clause ...)
  (set-my-match-lambda-procedure-procs! proc
                                        (append (list (clause->proc clause) ...)
                                                (my-match-lambda-procedure-procs proc))))

(struct exn:fail:my-match-lambda:no-match exn:fail (args) #:transparent)
(struct exn:fail:my-match-lambda:no-match:next-clause exn:fail:my-match-lambda:no-match () #:transparent)

(define (raise-my-match-lambda:no-match-error args)
  (define message
    (string-append
     "my-match-lambda: no clause matches" "\n"
     "  args: "(~v args)""))
  (define error-exn
    (with-handlers ([exn:fail? identity])
      (error message)))
  (define exn
    (cond [(within-my-match-lambda-append?)
           (exn:fail:my-match-lambda:no-match:next-clause
            message (exn-continuation-marks error-exn) args)]
          [else
           (exn:fail:my-match-lambda:no-match
            message (exn-continuation-marks error-exn) args)]))
  (raise exn))