improved error messages when handlers fail check-with tests

collects/2htdp/private/checked-cell.rkt

@@ -68,9 +68,14 @@
           (tp-error 'check-with "the test function ~a is expected to return a boolean, but it returned ~v" 
                     (object-name ok?) b))
         (unless b
+          (define check-with-name 
+            (let ([n (symbol->string (object-name ok?))])
+              (if (regexp-match "check-with" n)
+                  "handler"
+                  n)))
           (tp-error 'check-with "~a ~a ~v, which fails to pass check-with's ~a test"
                     tag (if say-evaluated-to "evaluated to" "returned") 
-                    nw (object-name ok?)))
+                    nw check-with-name))
         nw))
     
     ;; Symbol Any -> Void 

collects/2htdp/private/clauses-spec-and-process.rkt

@@ -86,7 +86,10 @@
                [(null? spec) #false]
                [(or (free-identifier=? (caar spec) kw)
                     (free-identifier=? (caar spec) kw-alt))
-                (syntax->list (cdar spec))]
+                ; (syntax->list (cdar spec))
+                (for/list ([i (syntax->list (cdar spec))])
+                  (define n  (string->symbol (format "~a handler" (syntax-e (caar spec)))))
+                  (syntax-property  i 'inferred-name n))]
                [else (loop (cdr spec))])))
          (if r ((third s) r) (fourth s)))
        Spec))

collects/2htdp/tests/key-error.rkt

@@ -18,3 +18,18 @@
                              (unless (and hdl (cons? (regexp-match "on-tick" (second hdl))))
                                (error 'test "expected: \"on-tick\", actual: ~e" (second hdl))))))
   (main))
+
+
+(define (my-fun x) "hi")
+
+(with-handlers ((exn:fail? 
+                 (lambda (x) 
+                   (define msg (exn-message x))
+                   (define hdl (regexp-match "check-with's handler test" msg))
+                   (unless hdl
+                     (error 'test "expected: \"check-with's handler test, error says: ~e" msg)))))
+  (big-bang 0 
+            [to-draw (lambda (x) (circle 1 'solid 'red))]
+            [on-tick (lambda (x) (my-fun x))]
+            [check-with (lambda (x) (number? x))])
+  (raise `(bad "must fail")))

collects/2htdp/xtest

@@ -10,6 +10,7 @@ run() {
 
 cd tests 
 
+run key-error.rkt
 run bad-draw.rkt
 run error-in-tick.rkt
 run error-in-draw.rkt
@@ -34,3 +35,4 @@ run record-stop-when.rkt
 run stop-when-crash.rkt
 run on-tick-universe-with-limit.rkt
 run on-tick-with-limit.rkt
+