; Based on the commented-out `test-error*` in the `test` egg (define-syntax test-error* (syntax-rules () ((_ ?msg (?kind (?properties ...)) ?expr) (let ((get-error-info (lambda (exn properties) (let ((kind (if (= (length (##sys#slot exn 1)) 1) (car (##sys#slot exn 1)) (##sys#slot exn 1)))) (list kind (flatten (map (lambda (l) (let ((property (car l))) (list property (get-condition-property exn kind property)))) (chop properties 2)))))))) (let-syntax ((error-info: (syntax-rules () ((_ ?expr) (condition-case (begin ?expr "") (exn () (get-error-info exn '(?properties ...)))))))) (test ?msg '(?kind (?properties ...)) (error-info: ?expr))))) ((_ ?msg ?kind ?expr) (test-error* ?msg (?kind ()) ?expr)) ((_ (?kind (?properties ...)) ?expr) (let ((render-properties (lambda (properties) (string-intersperse (map (lambda (l) (let ((property (car l)) (value (cadr l))) (sprintf "~A=~A" property value))) (chop properties 2)) ", "))))) (test-error* (sprintf "raises ~S with ~A" '?kind (render-properties '(?properties ...))) (?kind (?properties ...)) ?expr)) ((_ ?kind ?expr) (test-error* (sprintf "raises ~S" '?kind) (?kind ()) ?expr))))