diff --git a/collects/deinprogramm/contract/contract-syntax.ss b/collects/deinprogramm/contract/contract-syntax.ss index 8c99eb5bc3..d42f529d45 100644 --- a/collects/deinprogramm/contract/contract-syntax.ss +++ b/collects/deinprogramm/contract/contract-syntax.ss @@ -10,7 +10,8 @@ scheme/promise (for-syntax scheme/base) (for-syntax syntax/stx) - (for-syntax stepper/private/shared)) + (for-syntax stepper/private/shared) + (only-in lang/private/teachprims beginner-equal?)) (define-for-syntax (phase-lift stx) (with-syntax ((?stx stx)) @@ -46,7 +47,7 @@ (syntax->list #'((?temp ?exp) ...))))) #'(let ((?temp ?exp) ...) ?check ... - (make-case-contract '?name (list ?temp ...) ?stx))))) + (make-case-contract '?name (list ?temp ...) beginner-equal? ?stx))))) ((predicate ?exp) (with-syntax ((?stx (phase-lift stx)) (?name name)) diff --git a/collects/deinprogramm/contract/contract.ss b/collects/deinprogramm/contract/contract.ss index 5eb1183acc..7856d16c2c 100644 --- a/collects/deinprogramm/contract/contract.ss +++ b/collects/deinprogramm/contract/contract.ss @@ -194,7 +194,7 @@ syntax #f)) -(define (make-case-contract name cases syntax) +(define (make-case-contract name cases =? syntax) (make-contract name (lambda (self obj) @@ -203,12 +203,12 @@ ((null? cases) (contract-violation obj self #f #f) obj) - ((equal? (car cases) obj) + ((=? (car cases) obj) obj) (else (loop (cdr cases)))))) syntax - (delay (apply arbitrary-one-of equal? cases)))) + (delay (apply arbitrary-one-of =? cases)))) (define-struct procedure-to-blame (proc syntax)) diff --git a/collects/tests/deinprogramm/contract.ss b/collects/tests/deinprogramm/contract.ss index dee9e73148..0882233af3 100644 --- a/collects/tests/deinprogramm/contract.ss +++ b/collects/tests/deinprogramm/contract.ss @@ -129,7 +129,7 @@ (test-case "case" - (define foo-or-bar (make-case-contract 'foo-or-bar '("foo" "bar") 'foo-or-bar-marker)) + (define foo-or-bar (make-case-contract 'foo-or-bar '("foo" "bar") equal? 'foo-or-bar-marker)) (check-equal? (say-no (apply-contract foo-or-bar #f)) 'no) (check-equal? (say-no (apply-contract foo-or-bar "foo"))