install_unique_constructor($new_child_class,"id");

sub install_unique_constructor {
    no strict 'refs';
    my ($unique,$class) = @_;
    $class ||= caller;
    my %singleton;
    eval "package $class;" . q|
     sub new {
        my $class = shift;
        # this behavior should be consistent:
        my %args = 1 == @_ ? (id=>@_) : @_;
        my $key = $args{$unique};
        my $self = $singleton{$key};
        unless ( $self ) {
            $self = $class->SUPER::new(@_);
            $singleton{$key} = $self;
        }
        return $self;
    };
    1;
    |;
}