Here's another way of doing it, inspired by your code:

my $word = q{-\w'(),};

s{
  (^|[^$word])
  (
   (?:([$word])\3)+
  )
  (?=[^$word]|$)
 }{
  my @x = ($1, $2);
  $x[1] =~ s/(.)./$1/g;
  join '', @x;
 }xige;
}
[download]

That matches a complete "word" that consists entirely of doubled characters. The "word" is in $2; $1 holds the preceeding character. In the replacement, since I know that $2 contains only doubled characters, I just delete every other character. (Tested.)