From 3264a7fd61e8d8d1ecb28880fd5143f91e7f73f4 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 17 Oct 2013 17:14:24 -0400
Subject: [PATCH] Better error messages for class/object contracts

---
 .../tests/racket/contract/class.rkt           | 22 ++++++++++++++++++-
 .../racket/private/class-internal.rkt         |  6 ++---
 2 files changed, 24 insertions(+), 4 deletions(-)

diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
index 12b9cafd5b..85ca25ed12 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
@@ -1748,4 +1748,24 @@
      (class object%
        (super-new)
        (define/public (callback f) (f 1))))
-   promised-produced?)))
+   promised-produced?))
+
+(let ([expected-obj
+       (λ (exn) (regexp-match? #rx"promised: an object" (exn-message exn)))]
+      [expected-class
+       (λ (exn) (regexp-match? #rx"promised: a class" (exn-message exn)))])
+  (contract-error-test
+   'not-an-object-1
+   '(contract (object/c) 3 'pos 'neg)
+   expected-obj)
+
+  (contract-error-test
+   'not-an-object-2
+   '(contract (instanceof/c (class/c)) 3 'pos 'neg)
+   expected-obj)
+
+  (contract-error-test
+   'not-a-class-1
+   '(contract (class/c) 3 'pos 'neg)
+   expected-class)))
+
diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt
index c6fb9b80ee..9d8fc30536 100644
--- a/racket/collects/racket/private/class-internal.rkt
+++ b/racket/collects/racket/private/class-internal.rkt
@@ -2758,7 +2758,7 @@ An example
 
 (define (class/c-check-first-order ctc cls fail)
   (unless (class? cls)
-    (fail "not a class"))
+    (fail '(expected: "a class" given: "~v") cls))
   (let ([method-ht (class-method-ht cls)]
         [beta-methods (class-beta-methods cls)]
         [meth-flags (class-meth-flags cls)]) 
@@ -3516,7 +3516,7 @@ An example
 
 (define (check-object-contract obj methods fields fail)
   (unless (object? obj)
-    (fail "not a object"))
+    (fail '(expected: "an object" given: "~e") obj))
   (let ([cls (object-ref obj)])
     (let ([method-ht (class-method-ht cls)])
       (for ([m methods])
@@ -3580,7 +3580,7 @@ An example
       (let ([p (proj blame)])
         (λ (val)
           (unless (object? val)
-            (raise-blame-error blame val "expected an object, got ~v" val))
+            (raise-blame-error blame val '(expected: "an object" given: "~e") val))
           (let ([original-obj (if (has-original-object? val) (original-object val) val)]
                 [new-cls (p (object-ref val))])
             (impersonate-struct val object-ref (λ (o c) new-cls)